perm filename FOO[F78,JMC] blob
sn#402958 filedate 1978-12-11 generic text, type T, neo UTF8
(DEFUN NEEDEVAL (E)
(COND ((OR (EQ E NIL) (EQ E T) (NUMBERP E)) E)
((EQ (CAR E) 'QUOTE) (CADR E))
((EQ (CAR E) 'CAR) (CAR (NEEDEVAL (CADR E))))
((EQ (CAR E) 'CDR) (CDR (NEEDEVAL (CADR E))))
((EQ (CAR E) 'ATOM) (ATOM (NEEDEVAL (CADR E))))
((EQ (CAR E) 'NULL) (NULL (NEEDEVAL (CADR E))))
((EQ (CAR E) 'CONS)
(CONS (NEEDEVAL (CADR E)) (NEEDEVAL (CADDR E))))
((EQ (CAR E) 'EQUAL)
(EQUAL (NEEDEVAL (CADR E)) (NEEDEVAL (CADDR E))))
((EQ (CAR E) 'COND) (NEEDEVCOND (CDR E)))
((EQ (CAAR E) 'LAMBDA)
(NEEDEVAL (SUBLIS2 (PRUP (CADAR E) (CDR E)) (CADDAR E))))
((EQ (CAAR E) 'LABEL)
(NEEDEVAL (CONS (SUBST (CAR E) (CADAR E) (CADDAR E))
(CDR E))))))
(DEFUN PRUP (U V)
(COND ((NULL U) NIL)
(T (CONS (CONS (CAR U) (CAR V))
(PRUP (CDR U) (CDR V))))))
(DEFUN NEEDEVCOND (U)
(COND ((NEEDEVAL (CAAR U)) (NEEDEVAL (CADAR U)))
(T (NEEDEVCOND (CDR U)))))
(setq f1 '(label alt (lambda (u) (cond ((null u) nil) ((null (cdr u)) u)
(t (cons (car u) (alt (cdr (cdr u)))))))))
(defun sublis2 (a e) (cond ((null a) e)
((atom e) ((lambda (z) (cond ((null z) e) (t (cdr z)))) (assoc e a)))
((eq (car e) 'lambda) (cons 'lambda (sublis2 (strip (cadr e) a) (cdr e))))
(t (cons (sublis2 a (car e)) (sublis2 a (cdr e))))))
(defun strip (e a) (cond ((null a) nil) ((eq (caar a) e) (strip e (cdr a)))
(t (cons (car a) (strip e (cdr a))))))
(defun test (x) (needeval (list f1 (list 'quote x))))